home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Libs / CSP / short-path2.em < prev   
Encoding:
Text File  |  1993-07-18  |  3.8 KB  |  152 lines
  1. (defmodule short-path2
  2.   (standard0
  3.    loopsII
  4.    csp) ()
  5.  
  6.   ;; From Naff benchmarks ltd.
  7.  
  8.   (defun time (f) (let ((x (cpu-time)))
  9.             (f)
  10.             (- (cpu-time)
  11.                x)))
  12.  
  13.   (defun m1 () (main *weird-arcs* 6))
  14.  
  15.   ;; useful
  16.   (defun delq (a lst)
  17.     (delete a lst eq))
  18.  
  19.   (deflocal *terminator* -1)
  20.   (deflocal *max-val* 1e20)
  21.   
  22.   ;; hmm
  23.   (defun start-node (out-chans)
  24.     (mapcar (lambda (x)
  25.           (OUT x 'set-parent))
  26.         out-chans)
  27.     (mapcar (lambda (x) 'all-parents-set) out-chans)
  28.     (mapcar (lambda (x) 
  29.           (OUT x 0))
  30.         out-chans)
  31.     (format t "Start Node: Terminators~%\n")
  32.     (mapcar (lambda (x) (OUT x *terminator*))
  33.         out-chans)
  34.     0)
  35.  
  36.  
  37.  
  38.   (defun internal-node (inputs outputs min-val)
  39.     (cond ((null inputs)
  40.        (format t "I-Node terminating~%")
  41.        (mapcar (lambda (x) (OUT x *terminator*))
  42.            outputs)
  43.        min-val)
  44.       (t 
  45.        (IN-FROM (input val) inputs
  46.             (cond ((= val *terminator*)
  47.                (internal-node (delq input inputs) outputs min-val))
  48.               ((< val min-val)
  49.                (mapc (lambda (x) (OUT x val))
  50.                  outputs)
  51.                (internal-node inputs outputs val))
  52.               (t (internal-node inputs outputs min-val)))))))
  53.  
  54.   (defun dest-node (inputs output min-val)
  55.     (cond ((null inputs)
  56.        (OUT output min-val)
  57.        min-val)
  58.       (t (IN-FROM (input val) inputs
  59.               (cond ((= val *terminator*)
  60.                  (dest-node (delq input inputs) output min-val))
  61.                 ((< val min-val)
  62.                  (dest-node inputs output val))
  63.                 (t (dest-node inputs output min-val)))))))
  64.  
  65.   (defun arc (in out length)
  66.     (let ((val (IN in)))
  67.       (cond ((= val *terminator*) 
  68.          (OUT out *terminator*)
  69.          length)
  70.         (t (OUT out (+ val length))
  71.            (arc in out length)))))
  72.             
  73.   (defun result-printer (input)
  74.     (let ((x (IN input)))
  75.       (format t  "**Result is: ~a~%" x)
  76.       x))
  77.  
  78.  
  79.   (deflocal n-nodes 6)
  80.   (deflocal *simple-arcs* '((0 1 1) (0 2 1)
  81.                 (1 3 1) (1 4 1)
  82.                 (2 3 1) (2 4 1)
  83.                 (3 5 1) (4 5 1)))
  84.            
  85.   (deflocal *weird-arcs* '((0 1 1) (0 2 2) (0 5 10)
  86.                (1 3 2) (1 4 4)
  87.                (2 3 2) (2 4 1) 
  88.                (3 5 2) (4 5 4)))
  89.  
  90.   ;; make things readable...
  91.   (defun node-in-chan (arc)
  92.     (cadr arc))
  93.   (defun node-out-chan (arc)
  94.     (caddr arc))
  95.   (defun in-node (arc)
  96.     (caar arc))
  97.   (defun out-node (arc)
  98.     (cadar arc))
  99.   (defun arc-length (arc)
  100.     (caddar arc))
  101.     
  102.   (defun main (arcs n-nodes)
  103.     (let ((arc-chans (mapcar (lambda (arc)
  104.                    (list  arc (make-Channel) (make-Channel)))
  105.                  arcs))
  106.       (result-chan (make-Channel)))
  107.       (PAR (FOR (arc-list arc-chans) arc-list
  108.         (setq arc-list (cdr arc-list))
  109.         (format t "Starting arc: ~a\n" (car arc-list))
  110.         (arc (connect-channel-input (node-out-chan (car arc-list)))
  111.              (connect-channel-output (node-in-chan (car arc-list)))
  112.              (arc-length (car arc-list))))
  113.        (start-node
  114.         (mapcar (lambda (x) 
  115.               (connect-channel-output (node-out-chan x)))
  116.             (collect (lambda (arc-data)
  117.                    (cond ((= (in-node arc-data) 0)
  118.                       arc-data)
  119.                      (t nil)))
  120.                  arc-chans)))
  121.        (FOR (i 1) (< i (- n-nodes 1)) (++ i)
  122.         (internal-node
  123.          (mapcar (lambda (x) 
  124.                (connect-channel-input (node-in-chan x)))
  125.              (collect (lambda (arc-data)
  126.                     (cond ((= (out-node arc-data) i)
  127.                        arc-data)
  128.                       (t nil)))
  129.                   arc-chans))
  130.          (mapcar (lambda (x) 
  131.                (connect-channel-output (node-out-chan x)))
  132.              (collect (lambda (arc-data)
  133.                     (cond ((= (in-node arc-data) i)
  134.                        arc-data)
  135.                       (t nil)))
  136.                   arc-chans))
  137.          *max-val*))
  138.        (dest-node 
  139.         (mapcar (lambda (arc-data)
  140.               (connect-channel-input (node-in-chan arc-data)))
  141.             (collect (lambda (arc-data)
  142.                    (cond ((= (out-node arc-data)
  143.                      (- n-nodes 1))
  144.                       arc-data)
  145.                      (t nil)))
  146.                  arc-chans))
  147.         (connect-channel-output result-chan)
  148.         *max-val*)
  149.        (result-printer (connect-channel-input result-chan)))))
  150.   
  151.   )
  152.